Shareware Grab Bag/Shareware Grab Bag.iso/011/device3.arc/DEVICE3.PAS

Pascal/Delphi Source File | 1986-03-28 | 15.6 KB | 548 lines

program Manipulate_Device_Driver_Chain(input,output);
{*********************************************************************
 * DEVICE.PAS             program for displaying device driver chain *
 *                        for DOS 2.00,2.10,3.00,3.10                *
 *                                                                   *
 * by Tim MacNary         july 13,1985                               *
 *                        Turbo Pascal v. 2.00B PC-DOS               *
 *                                                                   *
 * Adapted from a Lattice C program by Stan Mitchell, published in   *
 * Dr. Dobb's Journal, #103 May, 1985, page 122.                     *
 * Please keep this comment here.                                    *
 *                                                                   *
 * Modification history:                                             *
 *    october 30,1985     Fixed a stupid bug in the Hex_Output       *
 *                        routine; it (of course) produced wrong     *
 *                        numbers if the high (sign) bit was set.    *
 *                        That was never a problem with this         *
 *                        program, because device drivers are        *
 *                        always in low memory, but if used in       *
 *                        another program, who knows?                *
 *                        Sorry - Tim MacNary                        *
 *    january 12,1986     Modified program so that device drivers    *
 *                        can be removed from the chain; this will   *
 *                        not remove them from memory, but they      *
 *                        will disappear as far as the operating     *
 *                        system is concerned.                       *
 *                        - Tim MacNary                              *
 *********************************************************************
    This routine uses fields of a standard FCB that Microsoft, in
 it's wisdom, declined to make public. Contained in each opened FCB
 are a Segment:Offset pair that point to the device driver used to
 access the opened file: if you open a disk file, then the driver
 interface to the disk drives is used; if the CON: device, then
 the console driver is used.
    DOS keeps track of the drivers by means of a linked list. Each
 driver has a header area which defines what that device can do, it's
 name, where it's entry points are, and the address of the next driver
 in the list. There is one special driver in the list: the NUL: device.
 It is always at the beginning of the list, so all other drivers will
 follow it.
     The routine to find the chain is as follows:

begin
   Determine what DOS version being used
   Exit if the version = 0 ( means dos 1.xx )
   Initialize an FCB with the NUL: device name.
   Open the device; exit if error.
   Get the pointers from the FCB; the pointers are in different places
     for DOS 2 and 3.
   Set up the screen --make it look nice
   Repeat
      Output the header
      Get the next header
   Until the next header offset field = $FFFF
   Output the last header
   Finish the screen display
end

}

const

   { DOS Function codes }
   OpenFCB  = $0F00;
   CloseFCB = $1000;
   DOS_Version  = $3000;

type
   DevHdr = record
      Next_Hdr_Offs,
      Next_Hdr_Seg,
      Attributes,
      Strategy,
      Interrupt:integer;
      Dev_Name:array[1..8] of char;
   end;

   DevHdr_Ptr = ^DevHdr;

   { The next two record types are used to access the pointers in
     the FCB }

   Reserve_V2 = record
      time: integer;
      attribute : byte;
      device_header_offset, device_header_segment: integer;
      Unknown : array[1..3] of byte;
   end;

   Reserve_V3 = record
      time: integer;
      attribute : integer;
      device_header_offset, device_header_segment: integer;
      Unknown : array[1..2] of byte;
   end;

   NameType = array[1..11] of char;

   FCB_Type = record
      drive:byte;
      fname:NameType;
      current_block :integer;
      record_size: integer;
      file_size: array[1..2] of integer;
      date: integer;
      RSU: array[1..10] of byte; { This is where the device pointer is stored }
      bset : array[1..5] of byte;
   end;


var
   device : DevHdr_Ptr;
   Version,Minor:integer;
   ch:char;

procedure Init_FCB(Drive:byte;Name:NameType;var File_Control_Block:FCB_Type);

{ Fill in the Drive and File fields of the FCB.
  Returns an initialized File Control Block. }

begin
   File_Control_Block.Drive:=Drive;
   File_Control_Block.FName:=Name;
end; { Init_FCB }

procedure Open_Device(var File_Control_Block:FCB_Type;var Error:integer);

{ The equivalent of either a reset or a rewrite in Turbo Pascal }

var  Regs: record
             AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags:integer;
          end;
begin
   Regs.DS:=SEG(File_Control_Block);
   Regs.DX:=OFS(File_Control_Block);
   Regs.AX:=OpenFCB;
   MSDOS(Regs);
   Error:=LO(Regs.AX);
end;


procedure Hex_Output(Value:integer);

{ Convert value to a hex string and output it, right-justified in a
  4 character field. }

function HexDigit(val:byte):char;
{ converts the low 4 bits to a hex number }
type
   _hextype =string[16];
const
   _hex : _hextype = '0123456789ABCDEF';
var
   ch:char;
begin
   ch:=_hex[(val and $0F) + 1];
   HexDigit:=ch;
end;

var
     OutStr:string[4];
     High, Low:byte;
begin
   OutStr:='';

   High:= Hi(Value);
   Low:= Lo(Value);

   OutStr:=HexDigit(high shr 4);
   OutStr:=OutStr + HexDigit(high);

   OutStr:=OutStr + HexDigit(low shr 4);
   OutStr:=OutStr + HexDigit(low);

   write(OutStr);

end { Hex_Output };

procedure Print_Header(Dev:DevHdr_Ptr);

{ Print a device driver header }

type Str4=string[4];
var  Co,Co2:integer;

procedure WriteIfEqual(Attributes,Mask:integer;Str:Str4;var Co:integer);

{ If an attribute is present, then print out a 4 character attribute indicator. }

begin
   if Attributes AND Mask <> 0 then
   begin
      write(Str);
      Co:=Co + 1
   end
end;

begin
   Co:=0;
   write('│ ');
   Hex_Output(SEG(Dev^));
   write('    │');
   Hex_Output(OFS(Dev^));
   write('   │ ');
   WITH Dev^ DO
   begin
      if (Attributes AND $8000) = 0000 then { Block device }
      begin
         write('# Drives:');
         { write out number of drives }
         write(ORD(Dev_Name[1]):2);
         write(' │         ');
      end
      else begin
         WriteIfEqual(Attributes,$0001,'StI ',Co);
         WriteIfEqual(Attributes,$0002,'StO ',Co);
         WriteIfEqual(Attributes,$0004,'Nul ',Co);
         WriteIfEqual(Attributes,$0008,'Clk ',Co);
         WriteIfEqual(Attributes,$0010,'Spl ',Co);
         WriteIfEqual(Attributes,$4000,'IOC ',Co);
         for Co2 := 1 TO (3-Co) do write('    ');
         write('│ ');
         for Co:=1 TO 8 DO write(Dev_Name[Co]); { Character device }
      end;
      write(' │');
      Hex_Output(Strategy);
      write('     │');
      Hex_Output(Interrupt);
      write('      │')
   end;
   writeln
end;

procedure Get_DOS_Version(var Major,Minor:integer);

{ Call MS-DOS to get the dos version number. The two returned values should
  be displayed: write(Major:1,'.',Minor:2);  Dos 1.xx will return a major
  version number of 0. }

var  Regs: record
             AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags:integer;
          end;
begin
   Regs.AX:=DOS_Version;
   MSDOS(Regs);
   Major:=LO(Regs.AX);
   Minor:=HI(Regs.AX);
end;

procedure Get_Head_of_Device_Chain(var Version,Minor:integer;
                                   var device:devHdr_Ptr);
{ Get nul: header location by Opening it; the FCB has fields containing
  the SEG:OFS of the NUL device. }
var
   File_Control_Block : FCB_Type;
   Error:integer;
   rsv2_x: ^reserve_V2;
   rsv3_x: ^reserve_V3;

begin
   Init_FCB(0,'NUL        ',File_Control_Block);
   Open_Device(File_Control_Block,Error);

   if Error = 0 then   { Nul device opened successfully }
   begin
      case Version of { DOS 2.xx and 3.xx allocate the FCB differently }
         2: { DOS 2.xx }
            begin
               rsv2_x:=PTR(SEG(File_Control_Block),
                           OFS(File_Control_Block)+22);
               Device:=PTR(rsv2_x^.Device_Header_Segment,
                           rsv2_x^.Device_Header_Offset);
            end;
         3: { DOS 3.xx }
            begin
               rsv3_x:=PTR(SEG(File_Control_Block),
                           OFS(File_Control_Block)+22);
               Device:=PTR(rsv3_x^.Device_Header_Segment,
                           rsv3_x^.Device_Header_Offset);
            end;
         else begin
            writeln('DOS Version ',Version:2,'.',Minor:2,' not supported.');
            halt;
         end;
      end; { case }
   end { if }
   else begin
      writeln('Error Opening Nul: device; error=',Error:1,'.');
      HALT
   end
end;


procedure Set_Up_Screen(Version,Minor:integer);

{ Write out the column headers, etc }

begin
   clrScr;
   write(  '                      ');
   TEXTCOLOR(BLACK);
   TEXTBACKGROUND(WHITE);
   writeln('╔═════════════════════╗');
   TEXTCOLOR(WHITE);
   TEXTBACKGROUND(BLACK);
   write(  '                      ');
   TEXTCOLOR(BLACK);
   TEXTBACKGROUND(WHITE);
   writeln('║ Device Driver Chain ║');
   writeln('╒═════════════════════╩═════════════════════╩═══════════════════╕');
   writeln('│ DOS Version ',Version:1,'.',Minor:2,'                                              │');
   writeln('├───────────────────────────────────────────────────────────────┤');
   writeln('│ Segment  Offset  Attributes    Name       Strategy  Interrupt │');
   writeln('├─────────┬───────┬─────────────┬──────────┬─────────┬──────────┤');
end; { Set_Up_Screen }

procedure Finish_Screen;
begin
   writeln('├─────────┴───────┴─────────────┴──────────┴─────────┴──────────┤');
   writeln('│ StI=Standard Input  StO=Standard Output  Nul=Nul Device       │');
   writeln('│ Spl=Special  Clk=Clock  IOC=Input/Output Control              │');
   writeln('└───────────────────────────────────────────────────────────────┘');
   TEXTCOLOR(White);
   TEXTBACKGROUND(Black);
end; { Finish_Screen }

procedure Display_Device_Chain(version,minor:integer;
                               device:devHdr_Ptr);
var temp:devHdr_Ptr;
begin
   temp:=device;
   Set_Up_Screen(Version,Minor);
   repeat { loop down the device chain }

      Print_Header(temp);

      { Get next header location }
      temp:=PTR(temp^.Next_Hdr_Seg,temp^.Next_Hdr_Offs);
   until ( temp^.Next_Hdr_Offs = $FFFF );    { Until last Header }

   Print_Header(temp);
   Finish_Screen;
   read(kbd);
end;

procedure display_device_names(device:devHdr_Ptr);
var
   temp:devhdr_Ptr;
   co:integer;
begin
   temp:=device;
   repeat
      for co:=1 to 8 do
         write(temp^.dev_Name[co]);
      write('  ');
      if WhereX >=69 then writeln;
      temp:=ptr(temp^.Next_Hdr_Seg,temp^.Next_Hdr_Offs);
   until (temp^.Next_Hdr_Offs = $FFFF );    { Until last Header }

   for co:=1 to 8 do
      write(temp^.dev_Name[co]);
   writeln;
end;

procedure input_device_name(var name:nametype);
var
   co:integer;
   ch:char;
begin
   for co:= 1 to 11 do
      name[co]:=' ';

   co:=0;
   ch:=' ';
   while (co < 8) and (ch <> #13) do
   begin
      read(kbd,ch);
      if (ch=#8) then
      begin
         if (co > 0) then
         begin
            co:=co-1;
            write(ch);
            write(' ');
            write(ch)
         end
      end
      else if ch=#13 then writeln
      else begin
         ch:=upcase(ch);
         write(ch);
         co:=co+1;
         name[co]:=ch;
      end
   end;

   writeln;
end;

procedure Find_Header(var Device,Temp:devHdr_Ptr;Name:nametype);
var
   co:integer;
   found:boolean;
   temp2:devHdr_Ptr;
begin
   temp2:=device;
   temp:=nil;
   found:=false;
   repeat
      if temp <> nil then { not first time }
      begin
         temp:=temp2;
         temp2:=PTR(temp2^.next_hdr_seg,temp2^.next_hdr_offs);
      end;

      co:=1;
      while (name[co]=temp2^.dev_name[co]) and (co <=8) do
      begin
         writeln(name[co],'=',temp2^.dev_name[co]);
         co:=co+1;
      end;

      if co=9 then { complete match }
         found:=true;

      if (temp=nil) and not found then temp:=temp2;

   until found or (temp2^.Next_Hdr_Offs = $FFFF );    { Until last Header }
   if not found then temp:=nil
   else writeln('Found');
end;

procedure change_device_name(var device:devHdr_Ptr);
var
   name,replace_name:nametype;
   temp,temp2:devHdr_Ptr;
   co:integer;
begin
   display_device_names(device);

   writeln('Input name of driver to change.');
   writeln('You will be prompted "Do you wish to change this header (Y/N) -> ",');
   write  ('after you input the driver name -> [        ]');
   gotoXY(whereX-9,whereY);

   input_device_name(name);
   write('[');
   for co:=1 to 8 do
      write(Name[co]);
   writeln(']');
   write('New name -> [        ]');
   gotoXY(whereX-9,whereY);
   input_device_name(replace_name);

   write('Do you wish to change this header (Y/N) -> ');
   read(kbd,ch); writeln(ch);
   if upcase(ch)='Y' then
   begin
      { Find the header }
      Find_Header(device,temp,name);

      if temp <> nil then
      begin
         temp2:=PTR(temp^.next_hdr_seg,temp^.next_hdr_Offs);
         for co:=1 to 8 do
            temp2^.dev_name[co]:=replace_name[co];
         writeln('Changed ...');
      end
      else writeln('Invalid Device')
   end
   else writeln('Aborted');
end;

procedure Remove_Device_Driver(Device:devHdr_Ptr);
{ Remove a selected device driver from the chain.

  WARNING:WARNING:WARNING:WARNING:WARNING:WARNING

     THIS WILL NOT REMOVE THE DEVICE DRIVER
     FROM MEMORY, NOR WILL IT TURN OFF ANY
     INTERRUPTS THE DRIVER MAY HAVE
     INITIALIZED
}

var
   name:nametype;
   temp,temp2:devHdr_Ptr;
   co:integer;


begin
   display_device_names(device);

   writeln('Input 8 chars indicating driver to remove, including any blanks.');
   writeln('You will be prompted "Do you wish to delete this header (Y/N) -> ",');
   write  ('after you input the driver name -> [        ]');
   gotoXY(whereX-9,whereY);

   input_device_name(name);
   write('[');
   for co:=1 to 8 do
      write(Name[co]);
   writeln(']');

   write('Do you wish to delete this header (Y/N) -> ');
   read(kbd,ch); writeln(ch);
   if upcase(ch)='Y' then
   begin
      { Find the header }
      Find_Header(device,temp,name);

      if temp <> nil then
      begin
         temp2:=PTR(temp^.next_hdr_seg,temp^.next_hdr_Offs);

         temp^.next_hdr_seg:=temp2^.next_hdr_seg;
         temp^.next_hdr_offs:=temp2^.next_hdr_offs;
         writeln('Removed ...');
      end
      else writeln('Invalid Device')
   end
   else writeln('Aborted');
end;

begin
   Get_DOS_Version(Version,Minor);
   if Version = 0 then { DOS 1.xx used }
   begin
      writeln('MS-DOS 2.xx or 3.xx required; press any key to continue ...');
      repeat until KEYPRESSED;
      HALT
   end;

   Get_Head_of_Device_Chain(Version,Minor,Device);
   Display_Device_Chain(version,minor,Device);
   repeat
      write('D(isplay, R(emove, C(hange, Q(uit -> ');
      read(kbd,ch); writeln(ch);
      case upcase(ch) of
         'D':Display_Device_Chain(version,minor,Device);
         'R':Remove_Device_Driver(Device);
         'C':Change_Device_Name(Device);
         'Q':writeln('Exiting ...');
         else writeln('Invalid input ');
      end
   until upcase(ch)='Q';
end.